home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue25 / icmp / ICMP.ZIP / IP_MISC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-07-02  |  24.7 KB  |  906 lines
  1. unit ip_misc;
  2. (*@/// interface *)
  3. interface
  4.   (*$x+ *)
  5.  
  6. (*@/// uses *)
  7. uses
  8.   sysutils,
  9. (*$ifdef ver80 *)
  10.   winprocs,
  11.   wintypes,
  12. (*$else *)
  13.   windows,
  14. (*$endif *)
  15.   winsock,
  16.   classes;
  17. (*@\\\*)
  18.  
  19. var
  20.   tcpip_ready: boolean;
  21. const
  22.   INVALID_IP_ADDRESS= $ffffffff;  (* only invalid as a host ip, maybe OK for broadcast *)
  23.  
  24. type
  25.   ta_8u=packed array [0..65530] of byte;
  26.   t_encoding=(uuencode,base64,mime);
  27.  
  28. (* The date in RFC 822 conform string format *)
  29. function internet_date(date: TDateTime):string;
  30.  
  31. (* Hostname (or IP-String) -> ip-address (in network order) *)
  32. function lookup_hostname(const hostname:string):longint;
  33.  
  34. (* Name of the local computer *)
  35. function my_hostname:string;
  36.  
  37. (* (Main) IP address of the local computer (network order *)
  38. function my_ip_address:longint;
  39.  
  40. (* IP-Address (network order) -> ###.###.###.### *)
  41. function ip2string(ip_address:longint):string;
  42.  
  43. (* IP-Address (network order) -> (Main) hostname *)
  44. function resolve_hostname(ip: longint):string;
  45.  
  46. (* Parse the n'th email address out of a string *)
  47. function address_from(const s:string; count: integer):string;
  48.  
  49. (* Binary stream -> Base64 (MIME) encoded strings and back *)
  50. function encode_base64(data: TStream):TStringList;
  51. function decode_base64(source:TStringList):TMemoryStream;
  52.  
  53. (* Find n'th occurence of a substring, from left or from right *)
  54. function posn(const s,t:string; count:integer):integer;
  55.  
  56. (* Find the n'th char unequal from left or from right *)
  57. function poscn(c:char; const s:string; n: integer):integer;
  58.  
  59. (* Parse the filename out of a DOS/UNC file and path name *)
  60. function filename_of(const s:string):string;
  61.  
  62. (* Delphi 1 didn't know these, but they are useful/necessary for D2/D3 *)
  63. (*$ifdef ver80 *)
  64. function trim(const s:string):string;
  65. procedure setlength(var s:string; l: byte);
  66. (*$endif *)
  67.  
  68. (* The offset to UTC/GMT in minutes of the local time zone *)
  69. function TimeZoneBias:longint;
  70.  
  71. (* Convert 8bit to 7bit and back *)
  72. function eight2seven_quoteprint(const s:string):string;
  73. function eight2seven_german(const s:string):string;
  74. function seven2eight_quoteprint(const s:string):string;
  75. (*@\\\0000002001*)
  76. (*@/// implementation *)
  77. implementation
  78.  
  79. (*@/// Some string utility functions *)
  80. (*@/// function posn(const s,t:string; count:integer):integer; *)
  81. function posn(const s,t:string; count:integer):integer;
  82.  
  83. { find the count'th occurence of the substring,
  84.   if count<0 then look from the back }
  85.  
  86. var
  87.   i,h,last: integer;
  88.   u: string;
  89. begin
  90.   u:=t;
  91.   if count>0 then begin
  92.     result:=length(t);
  93.     for i:=1 to count do begin
  94.       h:=pos(s,u);
  95.       if h>0 then
  96.         u:=copy(u,pos(s,u)+1,length(u))
  97.       else begin
  98.         u:='';
  99.         inc(result);
  100.         end;
  101.       end;
  102.     result:=result-length(u);
  103.     end
  104.   else if count<0 then begin
  105.     last:=0;
  106.     for i:=length(t) downto 1 do begin
  107.       u:=copy(t,i,length(t));
  108.       h:=pos(s,u);
  109.       if (h<>0) and (h+i<>last) then begin
  110.         last:=h+i-1;
  111.         inc(count);
  112.         if count=0 then BREAK;
  113.         end;
  114.       end;
  115.     if count=0 then result:=last
  116.                else result:=0;
  117.     end
  118.   else
  119.     result:=0;
  120.   end;
  121. (*@\\\*)
  122. (*@/// function poscn(c:char; const s:string; n: integer):integer; *)
  123. function poscn(c:char; const s:string; n: integer):integer;
  124.  
  125. { Find the n'th occurence of a character different to c,
  126.   if n<0 look from the back }
  127.  
  128. var
  129.   i: integer;
  130. begin
  131.   if n=0 then  n:=1;
  132.   if n>0 then begin
  133.     for i:=1 to length(s) do begin
  134.       if s[i]<>c then begin
  135.         dec(n);
  136.         result:=i;
  137.         if n=0 then begin
  138.           EXIT;
  139.           end;
  140.         end;
  141.       end;
  142.     end
  143.   else begin
  144.     for i:=length(s) downto 1 do begin
  145.       if s[i]<>c then begin
  146.         inc(n);
  147.         result:=i;
  148.         if n=0 then begin
  149.           EXIT;
  150.           end;
  151.         end;
  152.       end;
  153.     end;
  154.   poscn:=0;
  155.   end;
  156. (*@\\\0000000C10*)
  157. (*@/// function filename_of(const s:string):string; *)
  158. function filename_of(const s:string):string;
  159. var
  160.   t:integer;
  161. begin
  162.   t:=posn('\',s,-1);
  163.   if t>0 then
  164.     result:=copy(s,t+1,length(s))
  165.   else begin
  166.     t:=posn(':',s,-1);
  167.     if t>0 then
  168.       result:=copy(s,t+1,length(s))
  169.     else
  170.       result:=s;
  171.     end;
  172.   end;
  173. (*@\\\000000012D*)
  174. (*$ifdef ver80 *)
  175. (*@/// function trim(const s:string):string; *)
  176. function trim(const s:string):string;
  177. var
  178.   h: integer;
  179. begin
  180.   (* trim from left *)
  181.   h:=poscn(' ',s,1);
  182.   if h>0 then
  183.     result:=copy(s,h,length(s))
  184.   else
  185.     result:=s;
  186.   (* trim from right *)
  187.   h:=poscn(' ',result,-1);
  188.   if h>0 then
  189.     result:=copy(result,1,h);
  190.   end;
  191. (*@\\\0000000C0B*)
  192. (*@/// procedure setlength(var s:string; l: byte); *)
  193. procedure setlength(var s:string; l: byte);
  194. begin
  195.   s[0]:=char(l);
  196.   end;
  197. (*@\\\000000012C*)
  198. (*$endif *)
  199. (*@\\\0000000201*)
  200.  
  201. (*@/// function TimeZoneBias:longint;          // in minutes ! *)
  202. function TimeZoneBias:longint;
  203. (*@/// 16 bit way: try a 32bit API call via thunking layer, if that fails try the TZ *)
  204. (*$ifdef ver80 *)
  205. (*@/// function GetEnvVar(const s:string):string; *)
  206. function GetEnvVar(const s:string):string;
  207. var
  208.   L: Word;
  209.   P: PChar;
  210. begin
  211.   L := length(s);
  212.   P := GetDosEnvironment;
  213.   while P^ <> #0 do begin
  214.     if (StrLIComp(P, PChar(@s[1]), L) = 0) and (P[L] = '=') then begin
  215.       GetEnvVar := StrPas(P + L + 1);
  216.       EXIT;
  217.       end;
  218.     Inc(P, StrLen(P) + 1);
  219.     end;
  220.   GetEnvVar := '';
  221.   end;
  222. (*@\\\0000000922*)
  223.  
  224. (*@/// function day_in_month(month,year,weekday: word; count: integer):TDateTime; *)
  225. function day_in_month(month,year,weekday: word; count: integer):TDateTime;
  226. var
  227.   h: integer;
  228. begin
  229.   if count>0 then begin
  230.     h:=dayofweek(encodedate(year,month,1));
  231.     h:=((weekday-h+7) mod 7) +1 + (count-1)*7;
  232.     result:=encodedate(year,month,h);
  233.     end
  234.   else begin
  235.     h:=dayofweek(encodedate(year,month,1));
  236.     h:=((weekday-h+7) mod 7) +1 + 6*7;
  237.     while count<0 do begin
  238.       h:=h-7;
  239.       try
  240.         result:=encodedate(year,month,h);
  241.         inc(count);
  242.         if count=0 then EXIT;
  243.       except
  244.         end;
  245.       end;
  246.     end;
  247.   end;
  248. (*@\\\*)
  249. (*@/// function DayLight_Start:TDateTime;     // american way ! *)
  250. function DayLight_Start:TDateTime;
  251. var
  252.   y,m,d: word;
  253. begin
  254.   DecodeDate(now,y,m,d);
  255.   result:=day_in_month(4,y,1,1);
  256.   (* for european one: day_in_month(3,y,1,-1) *)
  257.   end;
  258. (*@\\\0000000701*)
  259. (*@/// function DayLight_End:TDateTime;       // american way ! *)
  260. function DayLight_End:TDateTime;
  261. var
  262.   y,m,d: word;
  263. begin
  264.   DecodeDate(now,y,m,d);
  265.   result:=day_in_month(10,y,1,-1);
  266.   end;
  267. (*@\\\000000060B*)
  268. type    (* stolen from windows.pas *)
  269. (*@///   TSystemTime = record ... end; *)
  270. PSystemTime = ^TSystemTime;
  271. TSystemTime = record
  272.   wYear: Word;
  273.   wMonth: Word;
  274.   wDayOfWeek: Word;
  275.   wDay: Word;
  276.   wHour: Word;
  277.   wMinute: Word;
  278.   wSecond: Word;
  279.   wMilliseconds: Word;
  280. end;
  281. (*@\\\0000000201*)
  282. (*@///   TTimeZoneInformation = record ... end; *)
  283. TTimeZoneInformation = record
  284.   Bias: Longint;
  285.   StandardName: array[0..31] of word;  (* wchar *)
  286.   StandardDate: TSystemTime;
  287.   StandardBias: Longint;
  288.   DaylightName: array[0..31] of word;  (* wchar *)
  289.   DaylightDate: TSystemTime;
  290.   DaylightBias: Longint;
  291.   end;
  292. (*@\\\*)
  293. var
  294.   tz_info: TTimeZoneInformation;
  295.   LL32:function (LibFileName: PChar; handle: longint; special: longint):Longint;
  296.   FL32:function (hDll: Longint):boolean;
  297.   GA32:function (hDll: Longint; functionname: PChar):longint;
  298.   CP32:function (buffer:TTimeZoneInformation; prochandle,adressconvert,dwParams:Longint):longint;
  299.   hdll32,dummy,farproc: longint;
  300.   hdll:THandle;
  301.   sign: integer;
  302.   s: string;
  303. begin
  304.   hDll:=GetModuleHandle('kernel');                  { get the 16bit handle of kernel }
  305.   @LL32:=GetProcAddress(hdll,'LoadLibraryEx32W');   { get the thunking layer functions }
  306.   @FL32:=GetProcAddress(hdll,'FreeLibrary32W');
  307.   @GA32:=GetProcAddress(hdll,'GetProcAddress32W');
  308.   @CP32:=GetProcAddress(hdll,'CallProc32W');
  309. (*@///   if possible then   call GetTimeZoneInformation via Thunking *)
  310. if (@LL32<>NIL) and
  311.    (@FL32<>NIL) and
  312.    (@GA32<>NIL) and
  313.    (@CP32<>NIL) then begin
  314.   hDll32:=LL32('kernel32.dll',dummy,1);            { get the 32bit handle of kernel32 }
  315.   farproc:=GA32(hDll32,'GetTimeZoneInformation');  { get the 32bit adress of the function }
  316.   case CP32(tz_info,farproc,1,1) of                { and call it }
  317.     1: result:=tz_info.StandardBias+tz_info.Bias;
  318.     2: result:=tz_info.DaylightBias+tz_info.Bias;
  319.     else result:=0;
  320.     end;
  321.   FL32(hDll32);                                    { and free the 32bit dll }
  322.   end
  323. (*@\\\0000000501*)
  324. (*@///   else  calculate the bias out of the TZ environment variable *)
  325. else begin
  326.   s:=GetEnvVar('TZ');
  327.   while (length(s)>0) and (not(s[1] in ['+','-','0'..'9'])) do
  328.     s:=copy(s,2,length(s));
  329.   case s[1] of
  330. (*@///     '+': *)
  331. '+': begin
  332.   sign:=1;
  333.   s:=copy(s,2,length(s));
  334.   end;
  335. (*@\\\*)
  336. (*@///     '-': *)
  337. '-': begin
  338.   sign:=-1;
  339.   s:=copy(s,2,length(s));
  340.   end;
  341. (*@\\\000000030A*)
  342.     else sign:=1;
  343.     end;
  344.   try
  345.     result:=strtoint(copy(s,1,2))*60;
  346.     s:=copy(s,3,length(s));
  347.   except
  348.     try
  349.       result:=strtoint(s[1])*60;
  350.       s:=copy(s,2,length(s));
  351.     except
  352.       result:=0;
  353.       end;
  354.     end;
  355. (*@///   if s[1]=':' then    minutes offset *)
  356. if s[1]=':' then begin
  357.   try
  358.     result:=result+strtoint(copy(s,2,2));
  359.     s:=copy(s,4,length(s));
  360.   except
  361.     try
  362.       result:=result+strtoint(s[2]);
  363.       s:=copy(s,3,length(s));
  364.     except
  365.       end;
  366.     end;
  367.   end;
  368. (*@\\\0000000A01*)
  369. (*@///   if s[1]=':' then    seconds offset - ignored *)
  370. if s[1]=':' then begin
  371.   try
  372.     strtoint(copy(s,2,2));
  373.     s:=copy(s,4,length(s));
  374.   except
  375.     try
  376.       strtoint(s[2]);
  377.       s:=copy(s,3,length(s));
  378.     except
  379.       end;
  380.     end;
  381.   end;
  382. (*@\\\0000000A01*)
  383.   result:=result*sign;
  384. (*@///   if length(s)>0 then daylight saving activated, calculate it *)
  385. if length(s)>0 then begin
  386.   (* forget about the few hours on the start/end day *)
  387.   if (now>daylight_start) and (now<DayLight_End+1) then
  388.     result:=result-60;
  389.   end;
  390. (*@\\\0000000401*)
  391.   end;
  392. (*@\\\*)
  393.   end;
  394. (*@\\\0000000201*)
  395. (*@/// 32 bit way: API call GetTimeZoneInformation *)
  396. (*$else *)
  397. var
  398.   tz_info: TTimeZoneInformation;
  399. begin
  400.   case GetTimeZoneInformation(tz_info) of
  401.     1: result:=tz_info.StandardBias+tz_info.Bias;
  402.     2: result:=tz_info.DaylightBias+tz_info.Bias;
  403.     else result:=0;
  404.     end;
  405.   end;
  406. (*$endif *)
  407. (*@\\\*)
  408. (*@\\\0000000201*)
  409.  
  410. const
  411.   bin2uue:string='`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
  412.   bin2b64:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  413.   uue2bin:string=' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_ ';
  414.   b642bin:string='~~~~~~~~~~~^~~~_TUVWXYZ[\]~~~|~~~ !"#$%&''()*+,-./0123456789~~~~~~:;<=>?@ABCDEFGHIJKLMNOPQRS';
  415.   linesize = 45;
  416.  
  417. (*@/// function decode_line(mode:t_encoding; const inp:string):string; *)
  418. function decode_line(mode:t_encoding; const inp:string):string;
  419. var
  420.   count,pos1,pos2: integer;
  421.   offset: shortint;
  422.   s: string;
  423.   out: string;
  424. begin
  425.   s:=inp;
  426.   setlength(out,length(s)*3 div 4 +3);
  427.   fillchar(out[1],length(s)*3 div 4 +3,#0);   (* worst case *)
  428.   if (mode=uuencode) and not (s[1] in [' '..'M','`']) then
  429.     count:=0   (* ignored line *)
  430.   else begin
  431.     count:=0; pos1:=0;  (* Delphi 2 Shut up! *)
  432.     case mode of  (* !!! No check for invalid data yet *)
  433. (*@///       uuencode:    set count,pos1, string -> Data into $00..$3F *)
  434. uuencode: begin
  435.   count:=(ord(s[1]) - $20) and $3f;
  436.   for pos1:=2 to length(s)-1 do
  437.     s[pos1]:=char(ord(uue2bin[ord(s[pos1])-$20+1])-$20);
  438.   pos1:=2;
  439.   end;
  440. (*@\\\0000000412*)
  441. (*@///       base64,mime: set count,pos1, string -> Data into $00..$3F *)
  442. base64,mime: begin
  443. {   count:=length(s)*3 div 4; }
  444.   count:=poscn('=',s,-1)*3 div 4;
  445.   for pos1:=1 to length(s) do
  446.     s[pos1]:=char(ord(b642bin[ord(s[pos1])-$20+1])-$20);
  447.   pos1:=1;
  448.   end;
  449. (*@\\\000000041F*)
  450.       end;
  451.     pos2:=1;
  452.     offset:=2;
  453.     while pos2<=count do begin
  454.       if (pos1>length(s)) or ((mode<>uuencode) and (s[pos1]='\'))  then begin
  455.         if offset<>2 then inc(pos2);
  456.         count:=pos2-1;
  457.         end
  458.       else if ((mode<>uuencode) and (s[pos1]='^')) then   (* illegal char in source *)
  459.         inc(pos1)  (* skip char, prevent endless loop jane :*)
  460.       else if offset>0 then begin
  461.         out[pos2]:=char(ord(out[pos2]) or (ord(s[pos1]) shl offset));
  462.         inc(pos1);
  463.         offset:=offset-6;
  464.         end
  465.       else if offset<0 then begin
  466.         offset:=abs(offset);
  467.         out[pos2]:=char(ord(out[pos2]) or (ord(s[pos1]) shr offset));
  468.         inc(pos2);
  469.         offset:=8-offset;
  470.         end
  471.       else begin
  472.         out[pos2]:=char(ord(out[pos2]) or ord(s[pos1]));
  473.         inc(pos1);
  474.         inc(pos2);
  475.         offset:=2;
  476.         end;
  477.       end;
  478.     end;
  479.   decode_line:=copy(out,1,count);
  480.   end;
  481. (*@\\\0000001501*)
  482. (*@/// function encode_line(mode:t_encoding; const buf; size:integer):string; *)
  483. function encode_line(mode:t_encoding; const buf; size:integer):string;
  484. var
  485.   buff: ta_8u absolute buf;
  486.   offset: shortint;
  487.   pos1,pos2: byte;
  488.   i: byte;
  489.   out: string;
  490. begin
  491.   setlength(out,size*4 div 3 + 4);
  492.   fillchar(out[1],size*4 div 3 +2,#0);   (* worst case *)
  493.   if mode=uuencode then begin
  494.     out[1]:=char(((size-1) and $3f)+$21);
  495.     size:=((size+2) div 3)*3;
  496.     end;
  497.   offset:=2;
  498.   pos1:=0;
  499.   pos2:=0;   (* Delphi 2 Shut up! *)
  500.   case mode of
  501.     uuencode:     pos2:=2;
  502.     base64, mime: pos2:=1;
  503.   end;
  504.   out[pos2]:=#0;
  505. (*@///   while pos1<size do begin ... end;     Das eigentliche Encoding *)
  506. while pos1<size do begin
  507.   if offset > 0 then begin
  508.     out[pos2]:=char(ord(out[pos2]) or ((buff[pos1] and ($3f shl offset)) shr offset));
  509.     offset:=offset-6;
  510.     inc(pos2);
  511.     out[pos2]:=#0;
  512.     end
  513.   else if offset < 0 then begin
  514.     offset:=abs(offset);
  515.     out[pos2]:=char(ord(out[pos2]) or ((buff[pos1] and ($3f shr offset)) shl offset));
  516.     offset:=8-offset;
  517.     inc(pos1);
  518.     end
  519.   else begin
  520.     out[pos2]:=char(ord(out[pos2]) or ((buff[pos1] and $3f)));
  521.     inc(pos2);
  522.     inc(pos1);
  523.     out[pos2]:=#0;
  524.     offset:=2;
  525.     end;
  526.   end;
  527. (*@\\\0000000D01*)
  528.   case mode of
  529. (*@///     uuencode: *)
  530. uuencode: begin
  531.   if offset=2 then dec(pos2);
  532.   for i:=2 to pos2 do
  533.     out[i]:=bin2uue[ord(out[i])+1];
  534.   end;
  535. (*@\\\0000000401*)
  536. (*@///     base64, mime: *)
  537. base64, mime: begin
  538.   if offset=2 then dec(pos2);
  539.   for i:=1 to pos2 do
  540.     out[i]:=bin2b64[ord(out[i])+1];
  541.   while (pos2 and 3)<>0  do begin
  542.     inc(pos2);
  543.     out[pos2]:='=';
  544.     end;
  545.   end;
  546. (*@\\\0000000301*)
  547.     end;
  548.   encode_line:=copy(out,1,pos2);
  549.   end;
  550. (*@\\\0000001A0E*)
  551.  
  552. (*@/// function encode_base64(data: TStream):TStringList; *)
  553. function encode_base64(data: TStream):TStringList;
  554. var
  555.   buf: pointer;
  556.   size: integer;
  557. begin
  558.   buf:=NIL;
  559. {   result:=NIL; }
  560.   try
  561.     result:=TStringList.Create;
  562.     getmem(buf,linesize);
  563.     data.seek(0,0);
  564.     size:=linesize;
  565.     while size>0 do begin
  566.       size:=data.read(buf^,linesize);
  567.       if size>0 then
  568.         result.add(encode_line(base64,buf^,size));
  569.       end;
  570.   finally
  571.     if buf<>NIL then
  572.       freemem(buf,linesize);
  573.     end;
  574.   end;
  575. (*@\\\0000000201*)
  576. (*@/// function decode_base64(source:TStringList):TMemoryStream; *)
  577. function decode_base64(source:TStringList):TMemoryStream;
  578. var
  579.   i: integer;
  580.   s: string;
  581. begin
  582.   result:=TMemoryStream.Create;
  583.   for i:=0 to source.count-1 do begin
  584.     s:=decode_line(base64,source[i]);
  585.     result.write(s[1],length(s));
  586.     end;
  587.   end;
  588. (*@\\\0000000701*)
  589.  
  590. (*@/// function eight2seven_quoteprint(const s:string):string; *)
  591. function eight2seven_quoteprint(const s:string):string;
  592. var
  593.   i: integer;
  594. begin
  595.   result:='';
  596.   for i:=1 to length(s) do
  597.     case s[i] of
  598.       '=',#$80..#$FF: result:=result+'='+uppercase(inttohex(ord(s[i]),2));
  599.       else            result:=result+s[i];
  600.       end;
  601.   end;
  602. (*@\\\0000000201*)
  603. (*@/// function eight2seven_german(const s:string):string; *)
  604. function eight2seven_german(const s:string):string;
  605. var
  606.   i: integer;
  607. begin
  608.   result:='';
  609.   for i:=1 to length(s) do
  610.     case s[i] of
  611.       #192..#195,#197: result:=result+'A';
  612.       #196,#198:       result:=result+'Ae';
  613.       #199:            result:=result+'C';
  614.       #200..#203:      result:=result+'E';
  615.       #204..#207:      result:=result+'I';
  616.       #209:            result:=result+'N';
  617.       #210..#213,#216: result:=result+'O';
  618.       #214:            result:=result+'Oe';
  619.       #217..#219:      result:=result+'U';
  620.       #220:            result:=result+'Ue';
  621.       #221:            result:=result+'Y';
  622.       #223:            result:=result+'ss';
  623.       #224..#227,#229: result:=result+'a';
  624.       #228,#230:       result:=result+'ae';
  625.       #231:            result:=result+'c';
  626.       #232..#235:      result:=result+'e';
  627.       #236..#239:      result:=result+'i';
  628.       #241:            result:=result+'n';
  629.       #242..#245,#248: result:=result+'o';
  630.       #246:            result:=result+'oe';
  631.       #249..#251:      result:=result+'u';
  632.       #252:            result:=result+'ue';
  633.       #255:            result:=result+'y';
  634.       #0..#60,#62..#127: result:=result+s[i];
  635.       else result:=result+'='+uppercase(inttohex(ord(s[i]),2));
  636.       end;
  637.   end;
  638. (*@\\\*)
  639. (*@/// function seven2eight_quoteprint(const s:string):string; *)
  640. function seven2eight_quoteprint(const s:string):string;
  641. var
  642.   i: integer;
  643. begin
  644.   result:='';
  645.   i:=0;
  646.   while i<length(s) do begin
  647.     inc(i);
  648.     case s[i] of
  649.       '=': try
  650.           result:=result+char(strtoint('$'+s[i+1]+s[i+2]));
  651.           i:=i+2;
  652.         except
  653.           result:=result+'=';
  654.         end;
  655.       else    result:=result+s[i];
  656.       end;
  657.     end;
  658.   end;
  659. (*@\\\0000001209*)
  660.  
  661.  
  662. (*@/// function my_hostname:string; *)
  663. function my_hostname:string;
  664. const
  665.   bufsize=255;
  666. var
  667.   buf: pointer;
  668.   RemoteHost : PHostEnt; (* No, don't free it! *)
  669. begin
  670.   buf:=NIL;
  671.   my_hostname:='';
  672.   try
  673.     getmem(buf,bufsize);
  674.     winsock.gethostname(buf,bufsize);   (* this one maybe without domain *)
  675.     if char(buf^)<>#0 then begin
  676.       RemoteHost:=Winsock.GetHostByName(buf);
  677. (*$ifdef ver80 *)
  678.       my_hostname:=strpas(pchar(RemoteHost^.h_name));
  679. (*$else *)
  680.       my_hostname:=pchar(RemoteHost^.h_name);
  681. (*$endif *)
  682.       end
  683.     else my_hostname:='127.0.0.1';    (* no Hostname received *)
  684.   finally
  685.     if buf<>NIL then  freemem(buf,bufsize);
  686.     end;
  687.   end;
  688. (*@\\\0000001501*)
  689. (*@/// function my_ip_address:longint; *)
  690. function my_ip_address:longint;
  691. const
  692.   bufsize=255;
  693. var
  694.   buf: pointer;
  695.   RemoteHost : PHostEnt; (* No, don't free it! *)
  696. begin
  697.   buf:=NIL;
  698.   try
  699.     getmem(buf,bufsize);
  700.     winsock.gethostname(buf,bufsize);   (* this one maybe without domain *)
  701.     RemoteHost:=Winsock.GetHostByName(buf);
  702.     if RemoteHost=NIL then
  703.       my_ip_address:=winsock.htonl($07000001)  (* 127.0.0.1 *)
  704.     else
  705.       my_ip_address:=longint(pointer(RemoteHost^.h_addr_list^)^);
  706.   finally
  707.     if buf<>NIL then  freemem(buf,bufsize);
  708.     end;
  709.   end;
  710. (*@\\\0000000E2E*)
  711. (*@/// function internet_date(date: TDateTime):string; *)
  712. function internet_date(date: TDateTime):string;
  713. (*@/// function myinttostr(value:integer; len:byte):string; *)
  714. function myinttostr(value:integer; len:byte):string;
  715. begin
  716.   myinttostr:=inttostr(value);
  717.   while length(result)<len do
  718.     result:='0'+result;
  719.   end;
  720. (*@\\\*)
  721. (*@/// function timezone:string; *)
  722. function timezone:string;
  723. var
  724.   bias: longint;
  725. begin
  726.   bias:=TimeZoneBias;
  727.   if bias=0 then
  728.     timezone:='GMT'
  729.   else if bias<0 then
  730.     timezone:='+' + myinttostr(abs(bias) div 60,2)
  731.                   + myinttostr(abs(bias) mod 60,2)
  732.   else if bias>0 then
  733.     timezone:='-' + myinttostr(bias div 60,2)
  734.                   + myinttostr(bias mod 60,2);
  735.   end;
  736. (*@\\\*)
  737. var
  738.   d,m,y,w,h,mm,s,ms: word;
  739. const
  740.   weekdays:array[1..7] of string[3]=('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
  741.   months:array[1..12] of string[3]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  742. begin
  743.   decodedate(date,y,m,d);
  744.   decodetime(date,h,mm,s,ms);
  745.   w:=dayofweek(date);
  746.   internet_date:=weekdays[w]+', '+inttostr(d)+' '+months[m]+' '+inttostr(y)+' '+
  747.      myinttostr(h,2)+':'+myinttostr(mm,2)+':'+myinttostr(s,2)+' '+timezone;
  748.   end;
  749. (*@\\\0000000201*)
  750. (*@/// function ip2string(ip_address:longint):string; *)
  751. function ip2string(ip_address:longint):string;
  752. begin
  753.   ip_address:=winsock.ntohl(ip_address);
  754.   result:= inttostr(ip_address shr 24)+'.'+
  755.            inttostr((ip_address shr 16) and $ff)+'.'+
  756.            inttostr((ip_address shr 8) and $ff)+'.'+
  757.            inttostr(ip_address and $ff);
  758.   end;
  759. (*@\\\0000000401*)
  760.  
  761. (*@/// function address_from(const s:string; count: integer):string; *)
  762. function address_from(const s:string; count: integer):string;
  763. var
  764.   p, ca, sp, co, se: integer;
  765. begin
  766.   (* search the count'th @ *)
  767.   ca:=posn('@',s,count);
  768.   if (ca=0) or (ca>length(s)) then
  769.     result:=''
  770.   else begin
  771.     (* search for delimiting char before the @ *)
  772.     sp:=posn(' ',copy(s,1,ca),-1);
  773.     co:=posn(',',copy(s,1,ca),-1);
  774.     se:=posn(';',copy(s,1,ca),-1);
  775.     p:=0;
  776.     if (sp<ca) and (sp>p) then  p:=sp;
  777.     if (co<ca) and (co>p) then  p:=co;
  778.     if (se<ca) and (se>p) then  p:=se;
  779.     result:=copy(s,p+1,length(s));
  780.     (* search for delimiting char after the @ *)
  781.     sp:=posn(' ',result,1)-1;
  782.     co:=posn(',',result,1)-1;
  783.     se:=posn(';',result,1)-1;
  784.     ca:=length(result);
  785.     p:=ca+1;
  786.     if (sp<p) and (sp>0) and (sp<ca) then  p:=sp;
  787.     if (co<p) and (co>0) and (co<ca) then  p:=co;
  788.     if (se<p) and (se>0) and (se<ca) then  p:=se;
  789.     result:=copy(result,1,p-1);
  790.     while result[1] in ['"','(','<'] do
  791.       result:=copy(result,2,length(result));
  792.     while result[length(result)] in ['"',')','>'] do
  793.       result:=copy(result,1,length(result)-1);
  794.     end;
  795.   end;
  796. (*@\\\0000001F35*)
  797.  
  798. (*@/// function lookup_hostname(const hostname:string):longint; *)
  799. function lookup_hostname(const hostname:string):longint;
  800. var
  801.   RemoteHost : PHostEnt;  (* no, don't free it! *)
  802.   ip_address: longint;
  803. (*$ifdef ver80 *)
  804.   s: string;
  805. (*$else *)
  806. (*$ifopt h- *)
  807.   s: string;
  808. (*$endif *)
  809. (*$endif *)
  810. begin
  811.   ip_address:=INVALID_IP_ADDRESS;
  812.   try
  813.     if hostname='' then begin  (* no host given! *)
  814.       lookup_hostname:=ip_address;
  815.       EXIT;
  816.       end
  817.     else begin
  818. (*@///       ip_address:=Winsock.Inet_Addr(PChar(hostname));  { try a xxx.xxx.xxx.xx first } *)
  819. (*$ifdef ver80 *)
  820.   s:=hostname+#0;
  821.   ip_address:=Winsock.Inet_Addr(PChar(@s[1]));  (* try a xxx.xxx.xxx.xx first *)
  822. (*$else *)
  823.  (*$ifopt h- *)
  824.   s:=hostname+#0;
  825.   ip_address:=Winsock.Inet_Addr(PChar(@s[1]));  (* try a xxx.xxx.xxx.xx first *)
  826.  (*$else *)
  827.   ip_address:=Winsock.Inet_Addr(PChar(hostname));  (* try a xxx.xxx.xxx.xx first *)
  828.  (*$endif *)
  829. (*$endif *)
  830. (*@\\\*)
  831.       if ip_address=SOCKET_ERROR then begin
  832. (*@///         RemoteHost:=Winsock.GetHostByName(PChar(hostname)); *)
  833. (*$ifdef ver80 *)
  834.   RemoteHost:=Winsock.GetHostByName(PChar(@s[1]));
  835. (*$else *)
  836.  (*$ifopt h- *)
  837.   RemoteHost:=Winsock.GetHostByName(PChar(@s[1]));
  838.  (*$else *)
  839.   RemoteHost:=Winsock.GetHostByName(PChar(hostname));
  840.  (*$endif *)
  841. (*$endif *)
  842. (*@\\\000000090C*)
  843.         if (RemoteHost=NIL) or (RemoteHost^.h_length<=0) then begin
  844.           lookup_hostname:=ip_address;
  845.           EXIT;  (* host not found *)
  846.           end
  847.         else
  848.           ip_address:=longint(pointer(RemoteHost^.h_addr_list^)^);
  849.             (* use the first address given *)
  850.         end;
  851.       end;
  852.   except
  853.     ip_address:=INVALID_IP_ADDRESS;
  854.     end;
  855.   lookup_hostname:=ip_address;
  856.   end;
  857. (*@\\\0000001601*)
  858. (*@/// function resolve_hostname(ip: longint):string; *)
  859. function resolve_hostname(ip: longint):string;
  860. var
  861.   RemoteHost : PHostEnt; (* No, don't free it! *)
  862.   ip_address: longint;
  863. begin
  864.   ip_address:=ip;
  865.   RemoteHost:=Winsock.GetHostByAddr(@ip_address,4,pf_inet);
  866.   if RemoteHost<>NIL then
  867. (*$ifdef ver80 *)
  868.     resolve_hostname:=strpas(pchar(RemoteHost^.h_name))
  869. (*$else *)
  870.     resolve_hostname:=pchar(RemoteHost^.h_name)
  871. (*$endif *)
  872.   else
  873.     resolve_hostname:=ip2string(ip_address);
  874.   end;
  875. (*@\\\0030000101000101001007*)
  876.  
  877. { Initialize and clean up the winsock DLL }
  878. (*@/// procedure init; *)
  879. procedure init;
  880. var
  881.   point: TWSAData;
  882. begin
  883.   tcpip_ready:=false;
  884.   if @Winsock.WSAStartup<>NIL then
  885.     case Winsock.WSAStartup($0101,point) of
  886.       WSAEINVAL, WSASYSNOTREADY, WSAVERNOTSUPPORTED: ;
  887.       else tcpip_ready:=true;
  888.       end;
  889.   end;
  890. (*@\\\0000000503*)
  891. (*@/// procedure shutdown; FAR; *)
  892. procedure shutdown; FAR;
  893. begin
  894.   if tcpip_ready then begin
  895.     Winsock.WSACancelBlockingCall;
  896.     Winsock.WSACleanup;
  897.     end;
  898.   end;
  899. (*@\\\0000000601*)
  900. (*@\\\000C00210100212F002101*)
  901. begin
  902.   init;
  903.   AddExitProc(Shutdown);
  904.   end.
  905. (*@\\\0003000301000011000301*)
  906.